home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / REDISP2.S < prev    next >
Encoding:
Text File  |  1993-08-21  |  14.0 KB  |  428 lines
  1. ;;;
  2. ;;;    Copyright (c) 1985 Massachusetts Institute of Technology
  3. ;;;
  4. ;;;    This material was developed by the Scheme project at the
  5. ;;;    Massachusetts Institute of Technology, Department of
  6. ;;;    Electrical Engineering and Computer Science.  Permission to
  7. ;;;    copy this software, to redistribute it, and to use it for any
  8. ;;;    purpose is granted, subject to the following restrictions and
  9. ;;;    understandings.
  10. ;;;
  11. ;;;    1. Any copy made of this software must include this copyright
  12. ;;;    notice in full.
  13. ;;;
  14. ;;;    2. Users of this software agree to make their best efforts (a)
  15. ;;;    to return to the MIT Scheme project any improvements or
  16. ;;;    extensions that they make, so that these may be included in
  17. ;;;    future releases; and (b) to inform MIT of noteworthy uses of
  18. ;;;    this software.
  19. ;;;
  20. ;;;    3.  All materials developed as a consequence of the use of
  21. ;;;    this software shall duly acknowledge such use, in accordance
  22. ;;;    with the usual standards of acknowledging credit in academic
  23. ;;;    research.
  24. ;;;
  25. ;;;    4. MIT has made no warrantee or representation that the
  26. ;;;    operation of this software will be error-free, and MIT is
  27. ;;;    under no obligation to provide any services, by way of
  28. ;;;    maintenance, update, or otherwise.
  29. ;;;
  30. ;;;    5.  In conjunction with products arising from the use of this
  31. ;;;    material, there shall be no use of the name of the
  32. ;;;    Massachusetts Institute of Technology nor of any adaptation
  33. ;;;    thereof in any advertising, promotional, or sales literature
  34. ;;;    without prior written consent from MIT in each case.
  35. ;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;
  38. ;;;     Modified by Texas Instruments Inc 10/21/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42.  
  43.  
  44. (define (window-scroll-y-absolute! window y-point)
  45.   (window-scroll-y-relative! window (- (window-point-y window) y-point)))
  46.  
  47. (define window-scroll-y-relative!
  48.   (letrec ((%receiver
  49.          (lambda (w)
  50.            (let ((buffer (vector-ref w window:buffer))
  51.              (table  (vector-ref w window:lines)))
  52.          (set-buffer-point! buffer (window-coordinates->mark w 0 0))
  53.          (vector-set! w window:point (buffer-point buffer))
  54.          (cursor-moved! w)))))
  55.      (lambda (window y-delta)
  56.        (cond ((negative? y-delta) (scroll-down-y! window (- y-delta)))
  57.          ((positive? y-delta) (scroll-up-y! window y-delta)))
  58.        (if (<> y-delta 0)
  59.        (begin
  60.         (set-start-end! window 0 (-1+ (vector-ref window window:y-size)))
  61.         (everything-changed! window %receiver))))))
  62.  
  63.  
  64. ;;; Scrolling
  65.  
  66. ;;; Scrolling down
  67.  
  68. (define (scroll-down-y! window y-delta)
  69.   (define (check-y-start y-delta table y-size)
  70.     (let ((y-start (inferior:y-start (vector-ref table y-delta))))
  71.       (if (< y-start y-delta)
  72.       (let ((y (max 0 y-start)))
  73.         (fill-entries y y-delta y-delta table y-size)
  74.         y)
  75.       y-delta)))
  76.  
  77.   (let ((table (vector-ref window window:lines))
  78.     (y-size (vector-ref window window:y-size)))
  79.     (if (< y-delta y-size)
  80.     (begin
  81.      (scroll-lines-down! window y-delta y-size table 0)
  82.      (let ((y (check-y-start y-delta table y-size)))
  83.        (fill-top! window (inferior:line (vector-ref table y))
  84.               table y-size y #F)))
  85.     (redraw-screen! window
  86.             (line-start
  87.               (make-mark (inferior:line (vector-ref table 0)) 0)
  88.               (- 0 y-delta) 'ERROR)
  89.             0))))
  90. (define (scroll-lines-down! window y-delta y-size table y)
  91.   (let loop ((n (-1+ (- y-size y-delta)))
  92.          (table table))
  93.        (if (< n y)
  94.        '()
  95.        (let ((inferior (vector-ref table n)))
  96.          (if (inferior:line inferior)
  97.          (begin
  98.           (set-inferior:line! (vector-ref table (+ n y-delta))
  99.                       #F)
  100.           (exchange-inferiors table n (+ n y-delta))))
  101.          (loop (-1+ n) table)))))
  102.  
  103.  
  104. (define (scroll-up-y! window y-delta)
  105.   (let ((table (vector-ref window window:lines))
  106.     (y-size (vector-ref window window:y-size)))
  107.     (if (< y-delta y-size)
  108.     (if (inferior:line (vector-ref table y-delta))
  109.         (scroll-lines-up! window y-delta y-size table y-delta)
  110.         '())
  111.     (redraw-screen! window
  112.             (line-start
  113.               (make-mark (inferior:line (vector-ref table 0)) 0)
  114.               y-delta 'ERROR)
  115.             0))))
  116.  
  117. (define (scroll-lines-up! window y-delta y-size table y)
  118.   (define (loop n y-size table)
  119.     (let ((move-to (- n y-delta)))
  120.       (if (or (>= n y-size)
  121.           (not (inferior:line (vector-ref table n))))
  122.       (fill-bottom! move-to y-size table
  123.             (inferior:line (vector-ref table (-1+ move-to))))
  124.       (begin
  125.         (set-inferior:line! (vector-ref table move-to) #F)
  126.         (exchange-inferiors table move-to n)
  127.         (loop (1+ n) y-size table)))))
  128.   (loop y y-size table))
  129.  
  130.  
  131. ;;; Fill top and Bottom
  132.  
  133. (define (fill-top! window %line table y-size n fill-bottom?)
  134.   (define (loop y table line)
  135.     (cond ((< y 0)
  136.        (if fill-bottom?
  137.                (let ((inferior (vector-ref table n)))
  138.          (let ((ys (inferior:y-size inferior))
  139.                (y-start (inferior:y-start inferior)))
  140.            (fill-bottom! (+ ys y-start) y-size table %line)))))
  141.       ((null? line)
  142.        (scroll-lines-up! window (+ y 1) y-size table (+ y 1)))
  143.       (else
  144.         (let ((inferior (vector-ref table y)))
  145.           (update-top-inferior! 0 y line table inferior y-size)
  146.           (loop (- y (inferior:y-size inferior)) table
  147.             (line-previous line))))))
  148.   (loop (-1+ n) table (line-previous %line)))
  149.  
  150. (define (update-top-inferior! x y line table inferior ys)
  151.   (let ((y-size (find-y-size line)))
  152.     (update-inferior! line x (1+ (- y y-size)) y-size inferior)
  153.     (if (> y-size 1)
  154.     (fill-entries (max 0 (1+ (- y y-size))) y y table ys))))
  155.  
  156.  
  157. ;;; Fill Bottom
  158.  
  159. (define (fill-bottom! n y-size table line)
  160.   (define (loop n line y-size table)
  161.     (if (< n y-size)
  162.     (let ((inferior (vector-ref table n)))
  163.       (if (null? line)
  164.           (begin
  165.         (set-inferior:line! inferior #F)
  166.         (loop (1+ n) '() y-size table))
  167.           (begin
  168.         (update-bottom-inferior! line 0 n inferior table y-size)
  169.         (loop (+ n (inferior:y-size inferior)) (line-next line)
  170.               y-size table))))))
  171.   (loop n (line-next line) y-size table))
  172.  
  173. (define (update-bottom-inferior! line x y inferior table ys)
  174.   (let ((y-size (find-y-size line)))
  175.     (update-inferior! line x y y-size inferior)
  176.     (if (> y-size 1)
  177.     (fill-entries (1+ y) (min ys (+ y y-size)) y table ys))))
  178.  
  179. (define (update-inferior! line x y y-size inferior)
  180.   (set-inferior:x-start! inferior x)
  181.   (set-inferior:y-start! inferior y)
  182.   (set-inferior:line! inferior line)
  183.   (set-inferior:y-size! inferior y-size))
  184.  
  185. ;;; Fill enteries
  186.  
  187. (define (fill-entries start end copy-entry table ys)
  188.   (let ((copy-entry (vector-ref table copy-entry)))
  189.     (do ((x-start (inferior:x-start copy-entry))
  190.      (y-start (inferior:y-start copy-entry))
  191.      (y-size  (inferior:y-size copy-entry))
  192.      (line    (inferior:line copy-entry))
  193.      (n start (1+ n)))
  194.     ((or (>= n ys) (= n end)) #T)
  195.       (and (>= n 0)
  196.        (let ((entry (vector-ref table n)))
  197.          (set-inferior:x-start! entry x-start)
  198.          (set-inferior:y-start! entry y-start)
  199.          (set-inferior:y-size! entry y-size)
  200.          (set-inferior:line! entry line))))))
  201.  
  202. (define (exchange-inferiors table n1 n2)
  203.   (let ((inferior1 (vector-ref table n1))
  204.     (inferior2 (vector-ref table n2))
  205.     (diff (- n2 n1)))
  206.     (set-inferior:y-start! inferior1
  207.          (+ diff (inferior:y-start inferior1)))
  208.     (set-inferior:y-start! inferior2
  209.          (- (inferior:y-start inferior2) diff))
  210.     (vector-set! table n1 inferior2)
  211.     (vector-set! table n2 inferior1)))
  212.  
  213.  
  214. (define (clean-up-table table n1 n2)
  215.   (do ((i n1 (1+ i))
  216.        (table table))
  217.       ((= i n2) table)
  218.     (set-inferior:line! (vector-ref table i) #F)))
  219.  
  220. (define (find-y-size line)
  221.   (let* ((string (line-string line))
  222.      (x (char->x string (string-length string))))
  223.     (if (zero? x)
  224.     1
  225.     (let ((q (quotient x (-1+ (ncols))))
  226.           (r (remainder x (-1+ (ncols)))))
  227.       (if (zero? r)
  228.           q
  229.           (1+ q))))))
  230.  
  231. (define (set-cursor-coordinates window mark)
  232.   (let ((line (mark-line mark))
  233.     (position (mark-position mark))
  234.     (string (line-string (mark-line mark)))
  235.     (x-size (window-x-size window))
  236.     (table (vector-ref window window:lines)))
  237.     (let ((y (inferior:y-start
  238.            (vector-ref table (line->y window line))))
  239.  
  240.       (x (char->x string position)))
  241.       (set-cursor-pos window
  242.               (index->x x x-size position string)
  243.               (+ y (index->y x x-size position string))))))
  244.  
  245.  
  246.  
  247. (define (index->x column x-size index string)
  248.   (if (zero? column)
  249.       0
  250.       (let ((r (remainder column (-1+ x-size))))
  251.     (if (zero? r)
  252.         (if (= index (string-length string))
  253.         (-1+ x-size)
  254.         r)
  255.         r))))
  256.  
  257. (define (index->y column x-size index string)
  258.   (if (zero? column)
  259.       0
  260.       (let ((q (quotient column (-1+ x-size)))
  261.         (r (remainder column (-1+ x-size))))
  262.     (if (zero? r)
  263.         (if (= index (string-length string))
  264.         (-1+ q)
  265.         q)
  266.         q))))
  267.  
  268.  
  269. (define make-insert-daemon
  270.   (lambda (window)
  271.     (letrec
  272.       ((%receiver
  273.      (lambda (region)
  274.        (region-components region
  275.          (lambda (start-line start-position end-line end-position)
  276.            (let* ((table (vector-ref window window:lines))
  277.               (inferior (vector-ref table y)))
  278.          (let ((y-size (vector-ref window window:y-size))
  279.                (old-ys (inferior:y-size inferior))
  280.                (new-ys (find-y-size start-line)))
  281.            (cond
  282.             ((eq? start-line end-line)
  283.              (if (= old-ys new-ys)
  284.              (begin
  285.               (maybe-marks-changed window y)
  286.               (set-start-end! window y y)
  287.               (cursor-moved! window))
  288.              (begin
  289.               (scroll-lines-down! window (- new-ys old-ys)
  290.                                   y-size table 
  291.                   (+ (inferior:y-start inferior) old-ys))
  292.               (set-inferior:y-size! inferior new-ys)
  293.               (fill-entries (1+ y) 
  294.                     (+ (inferior:y-start inferior) new-ys)
  295.                     y table y-size)
  296.               (set-start-end! window y (-1+ y-size))
  297.               (everything-changed! window window-redraw!))))
  298.             (else
  299.               (update-bottom-inferior! start-line 0 y
  300.                            inferior table y-size)
  301.               (fill-bottom! (+ y new-ys) y-size table start-line)
  302.               (set-start-end! window y (-1+ y-size))
  303.               (everything-changed! window window-redraw!)))))))))
  304.  
  305.        (y '()))
  306.     (lambda (mark)
  307.       (if (line-visible? window mark)
  308.       (begin
  309.         (set! y (line->y window (mark-line mark)))
  310.         %receiver))))))
  311.  
  312.  
  313. (define set-start-end!
  314.   (lambda (window start end)
  315.     (if (vector-ref window window:redisplay-window-flag)
  316.     (begin
  317.       (vector-set! window window:start
  318.                (min start (vector-ref window window:start)))
  319.       (vector-set! window window:end
  320.                (max end (vector-ref window window:end))))
  321.     (begin
  322.       (vector-set! window window:start start)
  323.       (vector-set! window window:end end)))
  324.      (vector-set! window window:redisplay-window-flag #T)))
  325.  
  326.  
  327.  
  328. (define make-delete-daemon
  329.   (lambda (window)
  330.     (letrec
  331.       ((start-y '())
  332.        (end-y '())
  333.        (mark '())
  334.   (%receiver
  335.     (lambda (region)
  336.       (let ((table (vector-ref window window:lines))
  337.         (line  (mark-line mark))
  338.         (y-size (vector-ref window window:y-size)))
  339.     (set! mark '())                     ;; clean up
  340.     (cond ((not start-y)            ;;; deleted top
  341.            (cond ((not end-y)
  342.               (window-redraw! window))
  343.              (else
  344.               (clean-up-table table 0 y-size)
  345.               (update-bottom-inferior! line 0 end-y
  346.                  (vector-ref table end-y) table y-size)
  347.               (fill-top! window line table y-size end-y #T)
  348.               (set-start-end! window 0 (-1+ y-size))
  349.               (everything-changed! window window-redraw!))))
  350.           ((and end-y (= start-y end-y))
  351.            (let ((inferior (vector-ref table start-y)))
  352.          (let ((old-ys (inferior:y-size inferior))
  353.                (new-ys (find-y-size line))
  354.                (y start-y))
  355.            (if (= old-ys new-ys)
  356.                (begin
  357.             (maybe-marks-changed window y)
  358.             (set-start-end! window y y)
  359.             (cursor-moved! window))
  360.                (begin
  361.             (scroll-lines-up! window (- old-ys new-ys)
  362.                                 y-size table 
  363.                     (+ (inferior:y-start inferior) old-ys))
  364.             (set-inferior:y-size! inferior new-ys)
  365.             (fill-entries (1+ y) 
  366.                       (+ (inferior:y-start inferior) new-ys)
  367.                       y table y-size)
  368.             (set-start-end! window y (-1+ y-size))
  369.             (everything-changed! window window-redraw!))))))
  370.           (else
  371.            (let ((inferior (vector-ref table start-y)))
  372.          (let ((ys (find-y-size line))
  373.                (y start-y))
  374.            (update-bottom-inferior! line 0 y inferior table y-size)
  375.            (fill-bottom! (+ y ys) y-size table line)
  376.            (set-start-end! window y (-1+ y-size))
  377.            (everything-changed! window window-redraw!)))))))))
  378.  
  379.     (lambda (region)
  380.       (let ((start (region-start region))
  381.         (end (region-end region)))
  382.     (let ((*line (mark-line start))
  383.           (*pos  (mark-position start)))
  384.       (set! start-y (line->y window *line))
  385.       (set! end-y (line->y window (mark-line end)))
  386.       (set! mark (if (and start-y end-y (= start-y end-y))
  387.              start
  388.              (mark-permanent! start)))
  389.       %receiver))))))
  390.  
  391.  
  392.  
  393.  
  394.  
  395. (define direct-output-for-insert!
  396.   (lambda (window char)
  397.     (let ((x (vector-ref window window:cursor-x))
  398.       (y (vector-ref window window:cursor-y))
  399.       (screen (vector-ref window window:screen)))
  400.       (maybe-marks-changed window y)
  401.       (write-string! screen char x y )
  402.       (vector-set! window window:cursor-x
  403.            (1+ x)))))
  404.  
  405. (define direct-output-forward-character!
  406.   (lambda (window)
  407.     (let ((screen (vector-ref window window:screen))
  408.       (buffer (vector-ref window window:buffer))
  409.       (point  (vector-ref window window:point))
  410.       (x (vector-ref window window:cursor-x)))
  411.       (set-buffer-point! buffer (mark1+ point #F))
  412.       (vector-set! window window:point (buffer-point buffer))
  413.       (%reify-port! screen screen:cursor-x (1+ x))
  414.       (vector-set! window window:cursor-x (1+ x)))))
  415.  
  416. (define direct-output-backward-character!
  417.   (lambda (window)
  418.     (let ((screen (vector-ref window window:screen))
  419.       (buffer (vector-ref window window:buffer))
  420.       (point  (vector-ref window window:point))
  421.       (x (vector-ref window window:cursor-x)))
  422.       (set-buffer-point! buffer (mark-1+ point #F))
  423.       (vector-set! window window:point (buffer-point buffer))
  424.       (%reify-port! screen screen:cursor-x (-1+ x))
  425.       (vector-set! window window:cursor-x (-1+ x)))))
  426.  
  427.  
  428.